home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d12
/
share.arc
/
SHARWARE.BAS
< prev
next >
Wrap
BASIC Source File
|
1988-02-04
|
28KB
|
725 lines
'┌───────────────────────────────────────────────────────────────────────┐
'│ SHARWARE is a DataBase program for keeping track of │
'│ program registrations. It was written for a few reasons: │
'│ │
'│ 1) I was asked to write it for a few shareware authors │
'│ 2) It serves as an example of the QBTOOLS/2 routines │
'│ 3) I wanted to see what I could write in 2 hours (usefully) │
'│ 4) I needed an example for the QBTOOLS/2 manual, this is it. │
'│ │
'│ Everything in this program bears my / our copyright. │
'│ All of the routines are QBTOOLS/2 routines. These are only a few │
'│ of the routines in the package. │
'│ │
'│ QBTOOLS/2 is available from │
'│ │
'│ Project X Software Development │
'│ 222 Church Street Ste 5g │
'│ Philadelphia, PA 19106-2251 │
'│ │
'│ Voice: 215-922-2557 │
'│ Data: 215-627-3910 │
'│ │
'│ (c) Copyright Roy Barrow, Project X Software Development │
'└───────────────────────────────────────────────────────────────────────┘
DECLARE FUNCTION DBValidate% (a%, b%) ' Input options based upon Up
' Down Arrow, or Page Down
DECLARE SUB SoftDB () ' Startup Screen. SoftDB was
' created with the Object
' Screen Generator.
'$INCLUDE: 'qbtools2.inc' ' STANDARD Routine Definitions
'$INCLUDE: 'qbtbtree.inc' ' BTREE Definitions
OPTION BASE 0
DEFINT A-Z
TYPE Customer ' Declare Customer Type
USED AS STRING * 1
FirstName AS STRING * 20
LastName AS STRING * 20
Title AS STRING * 20
Telephone AS STRING * 20
Address1 AS STRING * 30
Address2 AS STRING * 30
City AS STRING * 20
State AS STRING * 20
ZipCode AS STRING * 20
Country AS STRING * 20
Product AS STRING * 30
Version AS STRING * 20
DatePurch AS STRING * 8
Dealer AS STRING * 30
Comments AS STRING * 315
END TYPE
DIM Cust AS Customer ' Create variables of Cust Type
DIM TestCust AS Customer
DIM bx AS KeySelection ' Create KeySelectionBox Type
DIM Choice$(6), Delop$(4) ' Scroll Box & Message Values
DIM Ok%(50)
DIM Cmnt$(15) ' Comments on Customer
Choice$(1) = "Insert a new customer"
Choice$(2) = "Amend an existing customer"
Choice$(3) = "Delete (remove) a customer"
Choice$(4) = "Browse through customers"
Choice$(5) = "QUIT Program"
Choice$(6) = "Debugging .... delete files" ' Only for DEBUGGING
Mw% = 0 ' Maximum Width (So Far)
FOR j% = 1 TO 6
Mw% = Maximum%(LEN(Choice$(j%)), Mw%) ' New Maximum
NEXT j%
f1$ = "SOFTDATB.DAT" ' Software Registration DataBase
f2$ = "SOFTDAT1" ' Index 1 - First Name
f3$ = "SOFTDAT2" ' Index 2 - Last Name
IF FileExists%(f1$) = 0 THEN ' If it is NOT There then ...
IxNum1% = FREEFILE ' Get Free File Number
IndexCreate IxNum1%, f2$, 20 ' Create a FirstName INDEX
IxNum2% = FREEFILE ' Get Free File number
IndexCreate IxNum2%, f3$, 20 ' Create a LastName INDEX
END IF
IxNum1% = FREEFILE ' Get free File Number
IndexOpen IxNum1%, f2$, Xnm$(), Xk$(), Xh%() ' Open the Index
IxNum2% = FREEFILE ' Get free File Number
IndexOpen IxNum2%, f3$, Xnm$(), Xk$(), Xh%() ' Open the Index
DatFile% = FREEFILE ' Get free file Number
OPEN f1$ FOR RANDOM AS DatFile% LEN = LEN(Cust) ' Open the data file
DO
LOCATE 1, 1 ' Go to top of screen
' (Problem in QB4)
SoftDB ' Display the input frame (OSG type)
rv% = 1 ' Choice is initially 1
ScrollBox Choice$(), Mw%, 5, 30, 7, 7, 7, 0, 7, 0, 1, 5, Ok%(), rv%, rst$, GlbErr%
' Get the option
SELECT CASE rv% ' Select on choice
CASE 1 ' Insert a new customer
GOSUB InitCust ' Init Customer Data
GOSUB CustDetails ' Get the details,
' and write to disk
CASE 2 ' Amend an existing customer
Toggle% = 0 ' Search flag,
' For First or Last name
DO
bx.Row = 5 ' Key Select Box values
bx.Col = 25
bx.Lin = 10
bx.Exi = 1
bx.Init1 = "Type initial search key for the customer"
bx.Init2 = "An exact match is not needed."
bx.KeyLen = 20
IF Toggle% = 0 THEN ' Search on ?
bx.o1 = "F1 - Switch to first name search"
Ix% = IxNum1% ' Pass Index Number
ELSE
bx.o1 = "F1 - Switch to last name search"
Ix% = IxNum2% ' Pass Index Number
END IF
bx.Echoice = 0 ' What was selected
bx.Btype = 1 ' Border type
' Same as DrawBox values
bx.Nf = 7 ' Normal Foreground
bx.Nb = 0 ' Normal Background
bx.Sf = 0 ' Selected Foreground
bx.Sb = 7 ' Selected Background
bx.Ff = 7 ' Frame Foreground
bx.Fb = 0 ' Frame Background
KeySelectBox bx, Opt$, Ix%, Ky$, Mr%, Xnm$(), Xk$(), Xh%(), sc%
' Get a key, and values
IF bx.Echoice = -1 THEN ' INDEX IS Empty
Delop$(1) = "No changing available! There are no"
Delop$(2) = "items in the database to amend!"
Delop$(3) = ""
Delop$(4) = "Press any key to continue"
Message Delop$(), 4, 3, 7, 0, 7, 0 ' DIsplay Message &
' wait for a RETURN
EXIT DO
END IF
IF sc% > 0 AND Mr% > 0 THEN ' If the Record EXISTS
IF bx.Echoice = 1 THEN ' If F1 was chosen
Toggle% = 1 - Toggle% ' Toggle to other index
ELSE
GET #DatFile%, Mr%, Cust ' Get the record
GOSUB DisplayCust ' Display the details
TempFirst$ = Cust.FirstName ' Make copies of Keys
TempLast$ = Cust.LastName
GOSUB CustDetails ' Get changes and then
' Write details away
EXIT DO
END IF
ELSE ' Any (spurious) option
EXIT DO ' just ignore & exit
END IF
LOOP
CASE 3 ' Delete (remove) a customer
Toggle% = 0 ' Toggle Search
DO
bx.Row = 5 ' KeySelectBox values
bx.Col = 25
bx.Lin = 10
bx.Exi = 1
bx.Init1 = "Type initial search key for the customer"
bx.Init2 = "An exact match is not needed."
bx.KeyLen = 20
IF Toggle% = 0 THEN
bx.o1 = "F1 - Switch to first name search"
Ix% = IxNum1%
ELSE
bx.o1 = "F1 - Switch to last name search"
Ix% = IxNum2%
END IF
bx.Echoice = 0 ' What's selected
bx.Btype = 1 ' Border type
bx.Nf = 7
bx.Nb = 0
bx.Sf = 0
bx.Sb = 7
bx.Ff = 7
bx.Fb = 0
KeySelectBox bx, Opt$, Ix%, Ky$, Mr%, Xnm$(), Xk$(), Xh%(), sc%
IF bx.Echoice = -1 THEN ' Index is Empty
Delop$(1) = "No deleting available! There are no"
Delop$(2) = "items in the database to delete!"
Delop$(3) = ""
Delop$(4) = "Press any key to continue"
Message Delop$(), 4, 3, 7, 0, 7, 0
EXIT DO
END IF
IF Mr% > 0 AND sc% > 0 THEN
IF bx.Echoice = 1 THEN ' Function key 1
Toggle% = 1 - Toggle%
ELSE ' Otherwise,
IF Mr% THEN
GET #DatFile%, Mr%, Cust ' Get the details,
GOSUB DisplayCust ' display the details
Delop$(1) = "YES, go ahead and delete " + Cust.FirstName
Delop$(2) = "NO, I don't want to delete " + Cust.FirstName
' Setup Scroll Box
NMw% = 0
FOR j% = 1 TO 2
Trim Delop$(j%)
NMw% = Maximum%(LEN(Delop$(j%)), NMw%)
NEXT j%
Irv% = 1
ScrollBox Delop$(), NMw%, 2, 25, 1, 7, 7, 0, 7, 0, 1, 2, Ok%(), Irv%, rst$, GlbErr%
' Ask to Delete ?
IF Irv% = 1 THEN ' If 1, then YES
TempFirst$ = Cust.FirstName' Make copies of keys
TempLast$ = Cust.LastName
Mrec% = Mr%
Trim TempFirst$
Trim TempLast$
IndexFind IxNum2%, TempFirst$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
DO
IF Mchk% = Mrec% THEN ' YES! Found, so quit
EXIT DO
ELSE ' Continue looking
IndexNext IxNum2%, TempFirst$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
END IF
LOOP '
' FOUND, Now Delete
IndexKill IxNum2%, TempFirst$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
IndexFind IxNum1%, TempLast$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
DO
IF Mchk% = Mrec% THEN ' YES! Found, so quit
EXIT DO
ELSE ' Continue looking
IndexNext IxNum1%, TempLast$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
END IF '
LOOP
' DELETE It
IndexKill IxNum1%, TempLast$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
GOSUB InitCust ' Initialize Customer
Cust.USED = "F" ' Set flag to free
PUT #DatFile%, Mrec%, Cust ' Write blank Record
END IF ' Done
END IF
EXIT DO
END IF
ELSE
EXIT DO
END IF
LOOP
CASE 4 ' Browse through customers
Toggle% = 0
DO
bx.Row = 5
bx.Col = 25
bx.Lin = 10
bx.Exi = 1
bx.Init1 = "Type initial search key for the customer"
bx.Init2 = "An exact match is not needed."
bx.KeyLen = 20
IF Toggle% = 0 THEN
bx.o1 = "F1 - Switch to first name search"
Ix% = IxNum1%
ELSE
bx.o1 = "F1 - Switch to last name search"
Ix% = IxNum2%
END IF
bx.Echoice = 0 ' What's selected
bx.Btype = 1 ' Border type
bx.Nf = 7
bx.Nb = 0
bx.Sf = 0
bx.Sb = 7
bx.Ff = 7
bx.Fb = 0
KeySelectBox bx, Opt$, Ix%, Ky$, Mr%, Xnm$(), Xk$(), Xh%(), sc%
IF bx.Echoice = -1 THEN
Delop$(1) = "No browsing available! There are no items"
Delop$(2) = "in the database to browse through!"
Delop$(3) = ""
Delop$(4) = "Press any key to continue"
Message Delop$(), 4, 3, 7, 0, 7, 0
EXIT DO
END IF
IF bx.Echoice = 11 THEN
EXIT DO
END IF
IF bx.Echoice = 1 THEN
Toggle% = 1 - Toggle%
END IF
WHILE bx.Echoice = 12
GET #DatFile%, Mr%, Cust
GOSUB DisplayCust
Delop$(1) = "Next Customer"
Delop$(2) = "Previous Customer"
Delop$(3) = "Initiate new search"
Delop$(4) = "QUIT"
NMw% = 0
FOR j% = 1 TO 4
Trim Delop$(j%)
NMw% = Maximum%(LEN(Delop$(j%)), NMw%)
NEXT j%
IF Toggle% = 1 THEN
Ixv% = IxNum2%
Att% = Attributes%(0, 7, 0, 0)
ColorPrint "Browsing on first name", 22, 5, Att%
ELSE
Ixv% = IxNum1%
Att% = Attributes%(0, 7, 0, 0)
ColorPrint "Browsing on last name ", 22, 5, Att%
END IF
Irv% = 1
ScrollBox Delop$(), NMw%, 4, 2, 1, 7, 7, 0, 7, 0, 1, 4, Ok%(), Irv%, rst$, GlbErr%
IF Irv% = 3 THEN
bx.Echoice = 0
END IF
IF Irv% = 4 THEN
EXIT DO
END IF
IF Irv% = 1 THEN
IndexNext Ixv%, TempFirst$, Mr%, Xnm$(), Xk$(), Xh%(), sc%
ELSE
IndexPrevious Ixv%, TempLast$, Mr%, Xnm$(), Xk$(), Xh%(), sc%
END IF
WEND
LOOP
CASE 5 ' QUIT
IndexClose IxNum1%, Xnm$(), Xk$(), Xh%()
IndexClose IxNum2%, Xnm$(), Xk$(), Xh%()
EXIT DO
CASE 6
CLOSE
KILL f1$
KILL f2$ + ".*"
KILL f3$ + ".*"
END
CASE ELSE
END SELECT
LOOP
LOCATE 23, 1
END ' End of program
DisplayCust: ' Display details on screen
Att% = Attributes%(7, 0, 0, 0)
ColorPrint Cust.LastName, 6, 23, Att%
ColorPrint Cust.FirstName, 7, 23, Att%
ColorPrint Cust.Title, 8, 23, Att%
ColorPrint Cust.Telephone, 9, 23, Att%
ColorPrint Cust.Address1, 10, 23, Att%
ColorPrint Cust.Address2, 11, 23, Att%
ColorPrint Cust.City, 12, 23, Att%
ColorPrint Cust.State, 13, 23, Att%
ColorPrint Cust.ZipCode, 14, 23, Att%
ColorPrint Cust.Country, 15, 23, Att%
ColorPrint Cust.Product, 17, 23, Att%
ColorPrint Cust.Version, 18, 23, Att%
ColorPrint Cust.DatePurch, 19, 23, Att%
ColorPrint Cust.Dealer, 20, 23, Att%
FOR j% = 1 TO 15
Txt$ = MID$(Cust.Comments, (j% - 1) * 21 + 1, 21)
ColorPrint Txt$, 5 + j%, 58, Att%
NEXT j%
RETURN
InitCust: ' Set to blanks
Cust.LastName = ""
Cust.FirstName = ""
Cust.Title = ""
Cust.Telephone = ""
Cust.Address1 = ""
Cust.Address2 = ""
Cust.City = ""
Cust.State = ""
Cust.ZipCode = ""
Cust.Country = ""
Cust.Product = ""
Cust.Version = ""
Cust.DatePurch = ""
Cust.Dealer = ""
Cust.Comments = ""
RETURN
CustDetails: ' Get Details
Op% = 1
DO
SELECT CASE Op%
CASE 1
Txt$ = Cust.LastName
TextInput 0, 0, 1, 0, 1, 0, 1, 20, Txt$, 23, 6, 7, 0, 0, Ek%
Trim Txt$
IF LEN(Txt$) = 0 OR Ek% = 7 THEN
Op% = 99 ' Abort
ELSE
Cust.LastName = Txt$
Op% = Op% + 1
END IF
CASE 2
Txt$ = Cust.FirstName
TextInput 1, 0, 1, 0, 1, 0, 1, 20, Txt$, 23, 7, 7, 0, 0, Ek%
Cust.FirstName = Txt$
Trim Txt$
IF LEN(Txt$) = 0 OR Ek% = 7 THEN
Op% = 99 ' Abort
ELSE
IF Ek% = 1 THEN
Op% = Op% - 1
ELSE
Op% = Op% + 1
END IF
END IF
Att% = Attributes%(0, 7, 0, 0)
ColorPrint "Press PgDn when finished entering details", 22, 5, Att%
CASE 3
Txt$ = Cust.Title
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 8, 7, 0, 0, Ek%
Cust.Title = Txt$
Op% = DBValidate%(Ek%, Op%) ' Next Option Function
CASE 4
Txt$ = Cust.Telephone
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 9, 7, 0, 0, Ek%
Cust.Telephone = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 5
Txt$ = Cust.Address1
TextInput 1, 0, 1, 1, 1, 0, 0, 30, Txt$, 23, 10, 7, 0, 0, Ek%
Cust.Address1 = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 6
Txt$ = Cust.Address2
TextInput 1, 0, 1, 1, 1, 0, 0, 30, Txt$, 23, 11, 7, 0, 0, Ek%
Cust.Address2 = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 7
Txt$ = Cust.City
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 12, 7, 0, 0, Ek%
Cust.City = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 8
Txt$ = Cust.State
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 13, 7, 0, 0, Ek%
Cust.State = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 9
Txt$ = Cust.ZipCode
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 14, 7, 0, 0, Ek%
Cust.ZipCode = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 10
Txt$ = Cust.Country
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 15, 7, 0, 0, Ek%
Cust.Country = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 11
Txt$ = Cust.Product
TextInput 1, 0, 1, 1, 1, 0, 0, 30, Txt$, 23, 17, 7, 0, 0, Ek%
Cust.Product = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 12
Txt$ = Cust.Version
TextInput 1, 0, 1, 1, 1, 0, 0, 20, Txt$, 23, 18, 7, 0, 0, Ek%
Cust.Version = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 13
Txt$ = Cust.DatePurch
TextInput 1, 0, 1, 1, 1, 0, 0, 8, Txt$, 23, 19, 7, 0, 0, Ek%
Cust.DatePurch = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 14
Txt$ = Cust.Dealer
TextInput 1, 0, 1, 1, 1, 0, 0, 30, Txt$, 23, 20, 7, 0, 0, Ek%
Cust.Dealer = Txt$
Op% = DBValidate%(Ek%, Op%)
CASE 15 TO 29
FOR j% = 1 TO 15
Cmnt$(j%) = MID$(Cust.Comments, (j% - 1) * 21 + 1, 21)
NEXT j%
Txt$ = Cmnt$(Op% - 14)
TextInput 1, 0, 1, 1, 1, 0, 0, 21, Txt$, 58, Op% - 9, 7, 0, 0, Ek%
Cmnt$(Op% - 14) = Txt$
FOR j% = 1 TO 15
MID$(Cust.Comments, (j% - 1) * 21 + 1, 21) = Cmnt$(j%)
NEXT j%
Op% = DBValidate%(Ek%, Op%)
CASE 30 ' END REACHED
SELECT CASE rv% ' Now, do option
' based on INSERT
' or Change
CASE 1 ' INSERT
w& = LOF(DatFile%)
FreeRec% = 0
IF w& THEN
LastRec% = CINT(w& / LEN(Cust))
FOR j% = 1 TO LastRec%
GET #DatFile%, j%, TestCust
IF TestCust.USED = "F" THEN
FreeRec% = j%
EXIT FOR
END IF
NEXT j%
IF FreeRec% = 0 THEN
FreeRec% = j%
END IF
ELSE
FreeRec% = 1
END IF
Ky$ = Cust.LastName
IndexInsert IxNum1%, Ky$, FreeRec%, Xnm$(), Xk$(), Xh%(), sc%
IF sc% = 0 THEN
PRINT "Index Insertion failure, Last Name!"
END
END IF
Ky$ = Cust.FirstName
IndexInsert IxNum2%, Ky$, FreeRec%, Xnm$(), Xk$(), Xh%(), sc%
IF sc% = 0 THEN
PRINT "Index Insertion failure, First Name!"
END
END IF
Cust.USED = "U"
PUT #DatFile%, FreeRec%, Cust
EXIT DO ' INSERTED!
CASE 2 ' Amend
TempMrec% = Mr%
Mrec% = Mr%
Test1$ = Cust.FirstName ' Need copies of keys
Trim Test1$
Trim TempFirst$
Test2$ = Cust.LastName
Trim Test2$
Trim TempLast$
' If the Index Keys
' have been changed,
' then they need to be
' deleted, and the
' re-inserted. this
' is a painless task, as
' the index is ALWAYS
' current. It needs no
' re-builds or batch
' updates.
IF Test1$ <> TempFirst$ THEN ' Change Keys
IndexFind IxNum2%, TempFirst$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
DO
IF Mchk% = Mrec% THEN
EXIT DO
ELSE
IndexNext IxNum2%, TempFirst$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
END IF
LOOP
IndexKill IxNum2%, TempFirst$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
IndexInsert IxNum2%, Test1$, Mrec%, Xnm$(), Xk$(), Xh%(), sc%
END IF
Mrec% = TempMrec%
IF Test2$ <> TempLast$ THEN ' Change Keys
IndexFind IxNum1%, TempLast$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
DO
IF Mchk% = Mrec% THEN
EXIT DO
ELSE
IndexNext IxNum1%, TempLast$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
END IF
LOOP
IndexKill IxNum1%, TempLast$, Mchk%, Xnm$(), Xk$(), Xh%(), sc%
IndexInsert IxNum1%, Test2$, Mrec%, Xnm$(), Xk$(), Xh%(), sc%
END IF
Mrec% = TempMrec%
PUT #DatFile%, Mrec%, Cust ' Write away the new
' amended customer
EXIT DO
CASE ELSE
END SELECT
CASE 99
EXIT DO
CASE ELSE
BEEP
PRINT "Fatal Error!"
PRINT "This point in the program should never be reached."
END
END SELECT
LOOP
RETURN
END
' *********************************************************************
' * sharwar1.bas formatted from sharware.bas with option(s): MS CL A60
' * January 23, 1988 at 6:13 pm. Formatted by QBF (C)opyright 1988.
' * QBF is available from Inventories Unlimited, USA, (215) 922-2557.
' * Longest lines: 107(276), 100(411), 97(148), 96(298), 95(311).
' * Total lines = 760. Maximum indentation depth = 11.
' *********************************************************************
FUNCTION DBValidate% (a%, b%)
SELECT CASE a%
CASE 1 ' Up arrow pressed ?
DBValidate% = b% - 1 ' Decrease the count
CASE 4 ' Page Down pressed ?
DBValidate% = 30 ' Last Option
CASE ELSE ' Any other choice
DBValidate% = b% + 1 ' Increase the count
END SELECT
END FUNCTION